home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / prolog / sbprolog / amiga / builtin2.zoo / buffer.c < prev    next >
C/C++ Source or Header  |  1988-08-15  |  25KB  |  642 lines
  1. /************************************************************************
  2. *                                    *
  3. * The SB-Prolog System                            *
  4. * Copyright SUNY at Stony Brook, 1986; University of Arizona, 1987    *
  5. *                                    *
  6. ************************************************************************/
  7.  
  8. /*-----------------------------------------------------------------
  9. SB-Prolog is distributed in the hope that it will be useful,
  10. but WITHOUT ANY WARRANTY.  No author or distributor
  11. accepts responsibility to anyone for the consequences of using it
  12. or for whether it serves any particular purpose or works at all,
  13. unless he says so in writing.  Refer to the SB-Prolog General Public
  14. License for full details.
  15.  
  16. Everyone is granted permission to copy, modify and redistribute
  17. SB-Prolog, but only under the conditions described in the
  18. SB-Prolog General Public License.   A copy of this license is
  19. supposed to have been given to you along with SB-Prolog so you
  20. can know your rights and responsibilities.  It should be in a
  21. file named COPYING.  Among other things, the copyright notice
  22. and this notice must be preserved on all copies. 
  23. ------------------------------------------------------------------ */
  24.  
  25.  
  26. #include "builtin.h"
  27.  
  28. #define BACKWARDS 0    /* Direction parameter=0 means backwards, */
  29.             /* !=0 means forwards */
  30.  
  31. #define get_e_length(ptr) (get_length(ptr) < 65535 ? \
  32.             (word)get_length(ptr) : *(pw)(get_name(ptr)-4))
  33.  
  34. extern struct psc_rec *insert();
  35.  
  36. static byte perm = PERM;
  37. static byte temp = TEMP;
  38.  
  39. /* create a psc_entry on the heap. Len = 4 */
  40. word makenullbuff()
  41. {
  42.     word addr;
  43.     struct psc_rec *ptr;
  44.  
  45.     *hreg = (word)(hreg + 1);    /* fake first of pair */
  46.     addr = (word)hreg++;
  47.     ptr = (struct psc_rec *)hreg;
  48.     get_etype(ptr) = T_BUFF;
  49.     get_arity(ptr) = 0;
  50.     hreg += 2;  /* no ep and no hash link */
  51.     get_name(ptr) = (char *)hreg;
  52.     get_length(ptr) = 0;
  53.     return(addr | CS_TAG);
  54. }
  55.  
  56.  
  57. b_ALLOC_BUFF()   /* r1 = size; 
  58.             r2 = Buffer,  
  59.             r3 = 0=>perm, 1=>heap, 2=>subbuff 
  60.             r4 = Super-Buffer if there is one
  61.             r5 = Retcode */
  62.  
  63. { /* long lengths (>= 65535) are kept in 4 bytes immediately preceeding
  64.     the name */
  65.     register word op1, op3, op4;
  66.     register pw top;
  67.     struct psc_rec *ptr,  *pptr;
  68.     long rc, size, len, disp;
  69.     pw loc;
  70.     word addr;
  71.  
  72.     /* r1 should be bound to a number; r2 is free */
  73.     op1 = gregc(1); deref(op1);
  74.     size = intval(op1);
  75.     op3 = gregc(3); deref(op3);
  76.     rc = 0;
  77.     switch ((int)(intval(op3))) {
  78.     case 0: /* perm */
  79.         alloc_perm(size,&addr); /* addr: ptr to struct node for buff */
  80.         if (!unify(gregc(2), (addr | CS_TAG))) {Fail0;}
  81.         break;
  82.     case 1: /* heap */
  83.         addr = makenullbuff();
  84.         ptr = get_str_psc(addr);
  85.         if (size < 65535) get_length(ptr) = size;
  86.         else {get_length(ptr) = 65535; *hreg++ = size;}
  87.             get_name(ptr) = (char *) hreg;
  88.             hreg += (size+3) >> 2;
  89.         *(pw)(get_name(ptr)) = 4; /* disp of next free */
  90.         if (!unify(gregc(2), (addr | CS_TAG))) {Fail0;}
  91.         break;
  92.     case 2: /* subbuffer */
  93.         op4 = gregc(4); deref(op4); /* super buffer */
  94.         ptr = get_str_psc(op4);
  95.         len = get_e_length(ptr);
  96.         disp = *(pw)(get_name(ptr)); /* printf("disp %d\n", disp); */
  97.         loc = (pw)(get_name(ptr)+disp);
  98.         /* printf("disp: %d, size: %d, len: %d\n", disp, size, len); */
  99.         if (disp+12+size>len) rc = 1;
  100.         else {
  101.             *loc = (word)(loc+1);
  102.         addr = (word)loc++;
  103.         pptr = (struct psc_rec *)loc;
  104.         get_etype(pptr) = T_BUFF;
  105.         get_arity(pptr) = 0;
  106.             loc += 2; /*no ep, no hash link*/
  107.             if (size < 65535) get_length(pptr) = size; 
  108.             else {get_length(pptr) = 65535; *loc++ = size;}
  109.         get_name(pptr) = (char *) loc;
  110.         *(pw)(get_name(pptr)) = 4; /* disp of next free */
  111.         loc += (size+3) >> 2;
  112.         disp = (word)(((char *)loc) - get_name(ptr));
  113.         *(pw)(get_name(ptr)) = disp;
  114.         if (!unify(gregc(2), (addr | CS_TAG))) {Fail0;}
  115.         }
  116.     }
  117.     if (!unify(gregc(5), makeint(rc))) {Fail0;}
  118. }
  119.  
  120. /* b_BUFF_CODE inserts a word into, or extracts a word from, a buffer.
  121.    It is VERY low-level and implementation dependent. It is used to 
  122.    generate byte-code into a buffer, and retrieve a word from a buffer.
  123.    On entry, r1 is bound to a buffer, r2 is the offset in the buffer,
  124.    r3 contains a number indicating what internal word to generate,
  125.    r4 contains a term from which the word to insert in the buffer is
  126.    extracted, or a variable that is bound to the word extracted from
  127.    the buffer */
  128. b_BUFF_CODE()
  129. {
  130.     struct psc_rec *ptr, *pscptr4;
  131.     FILE *fdes;
  132.     int disc, disp, i, arity;
  133.     char s[100];
  134.     word tempvar, temp1, temp2;
  135.     register word op1, op4;
  136.     register pw top;
  137.  
  138.     op4 = gregc(1); deref(op4);
  139.     if (!isconstr(op4)) {errmsg(11); Fail0; return;}
  140.     ptr = get_str_psc(op4);
  141.     op4 = gregc(2); deref(op4); 
  142.     disp = intval(op4);
  143.     op4 = gregc(3); deref(op4); 
  144.     disc = intval(op4);
  145.     op4 = gregc(4); deref(op4); 
  146.     switch (disc) {
  147.     case 0: /* ppsc: constant/structure, untagged psc_ptr to buff */
  148.         /* make permanent if could be dangling pointer */
  149.         if ((word)get_name(ptr)<(word)get_str_psc(op4)) {
  150.         pscptr4 = get_str_psc(op4);
  151.         op4 = (word)insert(get_name(pscptr4), get_length(pscptr4), 
  152.                 get_arity(pscptr4), &perm) | CS_TAG;
  153.         }
  154.         *(pw)(get_name(ptr)+disp) = (word)(get_str_psc(op4));
  155.         break;
  156.     case 1:    /* pppsc: cons/struc, untagged ptr to psc_ptr to buff */
  157.         /* make permanent if could be dangling pointer */
  158.         if ((word)get_name(ptr)<(word)untagged(op4)) {
  159.         pscptr4 = get_str_psc(op4);
  160.         op4 = (word)insert(get_name(pscptr4), get_length(pscptr4), 
  161.                 get_arity(pscptr4), &perm);
  162.         }
  163.         *(pw)(get_name(ptr)+disp) = untagged(op4);
  164.         break;
  165.     case 2: /* pn: number, untagged word value to buff */
  166.         *(pw)(get_name(ptr)+disp) = intval(op4);
  167.         break;
  168.     case 3: /* pb: number, untagged byte value to buff */
  169.         *(byte *)(get_name(ptr)+disp) = intval(op4);
  170.         break;
  171.     case 4: /* ga: return address of location in buffer, as tagged num */
  172.         if (!unify(op4, makeint(get_name(ptr)+disp))) {Fail0;}
  173.         break;
  174.     case 5: /* gn: return word at location in buffer, as tagged num */
  175.         if (!unify(op4, makeint(*(pw)(get_name(ptr)+disp)))) {Fail0;}
  176.         break;
  177.     case 6: /* gb: return byte at location in buffer, as tagged num */
  178.         if (!unify(op4, makeint(*(byte *)(get_name(ptr)+disp)))) {Fail0;}
  179.         break;
  180.     case 7: /* gepb: return buff that 1st arg pred ep points to */
  181.         /* assumes ep points to 2nd word in buff, first is ptr to
  182.         its own psc_ptr */
  183.         if (!unify(op4, *(pw)(get_ep(ptr)-4))) {Fail0;}
  184.         break;
  185.     case 8: /* gpb: return buff that word at disp-buff points to */
  186.         if (!unify(op4, *(pw)((*(pw)(get_name(ptr)+disp))-4)))
  187.         {Fail0;}
  188.         break;
  189.     case 9: /* pep: set ep of term to point to 4th byte in buff */
  190.         get_ep(ptr) = (byte *)(get_name(get_str_psc(op4))+4);
  191.         get_etype(ptr) = T_DYNA;
  192.         /* and set 1st word of buff to point to buff psc ptr */
  193.         /* *(pw)get_name(get_str_psc(op4)) = op4; */
  194.         break;
  195.     case 10: /* pbr: set word p points to 4th byte in buff */
  196.         *(char **)(get_name(ptr)+disp) = get_name(get_str_psc(op4))+4;
  197.         /* and set 1st word of buff to point to buff psc ptr */
  198.         /* *(pw)get_name(get_str_psc(op4)) = op4; */
  199.         break;
  200.     case 11: /* rep: reset ep of first arg to undefined */
  201.         if (is_PRED(ptr) || is_DYNA(ptr)) {
  202.         get_ep(ptr) = 0;
  203.         get_etype(ptr) = T_ORDI;
  204.         }
  205.         break;
  206.     case 12: /* fv: free variable to buff, for use with getival instr */
  207.         temp1 = (word)(get_name(ptr)+disp);
  208.         if (!(temp1&3)) follow(temp1) = temp1;
  209.         else {
  210.         curr_fence = (byte *)(((int)curr_fence + 3) & 0xfffffffc);
  211.         follow(temp1) = (word)curr_fence;
  212.         follow(curr_fence) = (word)curr_fence;
  213.         curr_fence += 4;
  214.         }
  215.         break;
  216.     case 13: /* execb: branch into buffer,  using 4th arg as call */
  217.         pcreg = (pb)(get_name(ptr)+disp);
  218.         arity = get_arity(get_str_psc(op4));
  219.         untag(op4);
  220.         for ( i=1; i<=arity; i++) /*??++i??*/
  221.         gregc(i) = follow((pw)op4+i);
  222.         break;
  223.     case 14: /* ptv: number or const, tagged word value to buff */
  224.         /* make permanent if could be dangling pointer */
  225.         if (isconstr(op4) && (word)get_name(ptr)<(word)untagged(op4)) {
  226.         pscptr4 = get_str_psc(op4);
  227.         op4 = (word)((long)insert(get_name(pscptr4), 
  228.                 get_length(pscptr4), 
  229.                 get_arity(pscptr4), &perm) 
  230.             | CS_TAG);
  231.         }
  232.         *(pw)(get_name(ptr)+disp) = op4;
  233.         break;
  234.     case 15: /* ptp: put str-tagged pointer to second location */
  235.         *(pw)(get_name(ptr)+disp) = 
  236.         (word)((long)(get_name(ptr)+intval(op4)) | CS_TAG);
  237.         break;
  238.     case 16: /* ptl: put list-tagged pointer to second location */
  239.         *(pw)(get_name(ptr)+disp) = 
  240.         (word)((long)(get_name(ptr)+intval(op4)) | LIST_TAG);
  241.         break;
  242.     case 17: /* pvar: put variable into buffer */
  243.         tempvar = (word)(get_name(ptr)+disp);
  244.         follow(tempvar) = tempvar;
  245.         if (op4 >= (word)get_name(ptr) 
  246.         && op4 <= (word)(get_name(ptr)+get_e_length(ptr)))
  247.         /* already points into the buffer */
  248.         follow(op4) = tempvar; /* point word to it */
  249.         else {
  250.         follow(op4) = tempvar;
  251.         pushtrail(op4);    /* and trail! */
  252.         }
  253.         break;
  254.     case 18: /* ubv: unify value with buffer */
  255.         if (!unify(get_name(ptr)+disp, op4)) {Fail0;}
  256.         break;
  257.     case 19: /* cep: copy ep of last arg to ep of first */
  258.         pscptr4 = get_str_psc(op4);
  259.         if (!is_BUFF(ptr)) {
  260.         get_ep(ptr) = get_ep(pscptr4);
  261.         get_etype(ptr) = get_etype(pscptr4);
  262.         }
  263.         break;
  264.     case 20: /* pepb: copy ep of last arg to loc in buff */
  265.         pscptr4 = get_str_psc(op4);
  266.         follow(get_name(ptr)+disp) = (word)(get_ep(pscptr4));
  267.         break;
  268.     case 21: /*gnb: return next buffer along the hash chain */
  269.         op1 = *(pw)(get_name(ptr) + disp);
  270.         op1 = *(pw)(op1 + 8) - 10;
  271.         if (!unify(op4, *(pw)op1)) {Fail0;}
  272.         break;
  273.     case 22: /*dis: disassemble buffer for debugging assert */
  274.          /*op1: buffer; op2: 0 for "w" 1 for "a"; op4: filename */
  275.         pscptr4 = get_str_psc(op4);
  276.         temp1 = (word)pcreg; temp2 = num_line;
  277.         num_line = 1;
  278.         namestring(pscptr4, s);
  279.         if (disp == 0) 
  280.         fdes = fopen(s, "w");
  281.         else fdes = fopen(s, "a");
  282.         fprintf(fdes, "\n /* New Buffer Below: pscptr, arity, length, nameptr, backptr */\n\n");
  283.         fprintf(fdes, "%x, %d, %d, %x, %x \n", ptr, get_arity(ptr),
  284.         get_length(ptr), get_name(ptr), get_ep(ptr));
  285.         pcreg = (byte *)(get_name(ptr) + 4);
  286.         while (pcreg < (byte *)(get_name(ptr) + get_length(ptr))) 
  287.         print_inst(fdes, pcreg);
  288.         fflush(fdes); fclose(fdes);
  289.         pcreg = (byte *)temp1; num_line = temp2;
  290.         break;
  291.     case 23: /* ps: short number, untagged word value to buff */
  292.         *(short *)(get_name(ptr)+disp) = intval(op4);
  293.         break;
  294.     case 24: /* gs: return short number at location in buffer, 
  295.             as tagged num */
  296.         if (!unify(op4, makeint(*(short *)(get_name(ptr)+disp)))) {Fail0;}
  297.         break;
  298.     case 25: /* bb: build a buffer for a pointer in a buffer, 0 len  */
  299.         temp1 = makenullbuff();
  300.         pscptr4 = get_str_psc(temp1);
  301.         get_name(pscptr4) = *(char **)(get_name(ptr)+disp);
  302.         if (!unify(op4, temp1)) {Fail0;}
  303.         break;
  304.     case 26: /* pba: put buffer address into buffer */
  305.         pscptr4 = get_str_psc(op4);
  306.         follow(get_name(ptr)+disp) = (word)(get_name(pscptr4));
  307.         break;
  308.     case 27: /* pf: put float (in WAM format, word) into buffer */
  309.         *(pw)(get_name(ptr)+disp) = op4;
  310.         break;
  311.     case 28: /* gppsc: get ptr to psc_table entry */
  312.         if (!unify(op4, (*(pw)(get_name(ptr)+disp))|CS_TAG)) {Fail0;}
  313.         break;
  314.     case 29: /* gf: get float (in WAM format, word) from buffer */
  315.         if (!unify(op4, *(pw)(get_name(ptr)+disp))) {Fail0;}
  316.         break;
  317.     }
  318. }
  319.  
  320. b_TRIMBUFF()
  321.     /* reg1 : new length (if <0 scan for 0x00)
  322.        reg2 : buffer
  323.        reg3 : 0 => perm, 1 => temp, 2 => temp in superbuff (r4)
  324.        reg4 : superbuff to trim (if 2) */
  325. {
  326.     struct psc_rec *ptr, *bptr;
  327.     register word op, op1, op3;
  328.     register pw top;
  329.     long len;
  330.  
  331.     op3 = gregc(3); deref(op3); op3 = intval(op3);
  332.     op = gregc(2); deref(op); ptr = get_str_psc(op);
  333.     op1 = gregc(1); deref(op1); len = intval(op1);
  334.     if (len<0)
  335.         {if (get_name(ptr)) len = strlen(get_name(ptr));
  336.      else {Fail0;}
  337.     }
  338.     else if (op3 == 0) { /* perm */
  339.     if (curr_fence == (byte *)(get_name(ptr) + get_length(ptr))) 
  340.         curr_fence = (byte *)(get_name(ptr) + len);
  341.     }
  342.     else if (op3 == 1) { /* heap */
  343.     if (hreg == (pw)(get_name(ptr) + get_e_length(ptr)))
  344.         hreg = (pw)(get_name(ptr) + len);
  345.     }
  346.     else {  /* in superbuffer */
  347.     op = gregc(4); deref(op); bptr = get_str_psc(op);
  348.     if ((word)get_name(bptr)+*(pw)get_name(bptr) == 
  349.             (word)get_name(ptr) + get_e_length(ptr))
  350.         *(pw)(get_name(bptr)) = /* new disp */
  351.             (((word)get_name(ptr)+len-(word)get_name(bptr))+3)&0xfffffffc;
  352.     }
  353.     if (get_length(ptr) < 65535) get_length(ptr) = len;
  354.     else *(pw)(get_name(ptr)-4) = len;
  355. }
  356.  
  357. b_SUBSTRING()
  358.        /* reg1 = direction (forwards for read,  backwards for write)
  359.           reg2 = numbytes
  360.           reg3 = Internal constant
  361.           reg4 = Initial location in the input buffer 
  362.           reg5 = Input Buffer  (must be a valid constant)
  363.           reg6 = Final location in the input buffer after reading from or
  364.                  writing into the buffer
  365.  
  366. /* Forwards: If the internal constant parameter is free upon entry,  it
  367.              takes the first numbytes of the input buffer and creates
  368.              an internal constant.  Reg 6 gets bound to the location
  369.              in the input buffer directly following the constant. If the
  370.              constant parameter is already bound, it is checked against 
  371.              the one in the buffer to see if they unify.  The numbytes
  372.              parameter must unify with the length of the constant.
  373.  
  374.   Backwards: Binds numbytes(if not bound) to the length of the internal
  375.              constant. Copies the internal constant into the Input Buffer,
  376.              and returns in reg 6 an index into the input buffer which 
  377.              directly follows the constant.
  378. */
  379.  
  380.  { /* define local variables */
  381.     char *Bnameptr, *Cnameptr;        /* Buffer Nameptr, Constant Nameptr */
  382.     struct psc_rec *buff_psc;        /* pointer to psc rec of buffer */
  383.     struct psc_rec *addr;        /* Holds result from insert */
  384.     int  offset,            /* Offset into buffer  */
  385.        numbytes,            /* Numbytes in buffer for constant */
  386.            i;                /* Counter */
  387.     word op1, op2, op3, op4, op5;
  388.     register pw top;
  389.  
  390.     op1 = gregc(1); deref(op1);        /* direction */
  391.     op2 = gregc(2);                /* length */
  392.     op3 = gregc(3); deref(op3);        /* constant substring */
  393.     op4 = gregc(4); deref(op4);        /* offset */
  394.     op5 = gregc(5); deref(op5);        /* constant, long string */
  395.     
  396.         /* check the direction param for error */
  397.     if (!isinteger(op1)) {errmsg(0); Fail0; return;}
  398.         /* check input buffer - ?valid constant */
  399.     if (!isatom(op5)) {errmsg(8); Fail0; return;}
  400.     buff_psc = get_str_psc(op5);
  401.         /* check that offset is valid */
  402.     if (!isinteger(op4)) {errmsg(2); Fail0; return;}
  403.     offset = intval(op4);
  404.     if ((get_length(buff_psc) < offset) || (offset < 0))
  405.     {errmsg(3); Fail0; return;}
  406.         /* get length of substring */
  407.     if ((isatom(op3)) &&
  408.     (!unify(op2, makeint(get_length(get_str_psc(op3))))))
  409.         {Fail0; return;}
  410.     deref(op2); 
  411.     if (!isinteger(op2)) {errmsg(4); Fail0; return;}
  412.     numbytes = intval(op2);
  413.         /* check no buffer overflow */
  414.     if ((numbytes < 0) || ((offset+numbytes) > get_length(buff_psc)))
  415.     {errmsg(3); Fail0; return;}
  416.  
  417.     if (intval(op1) != BACKWARDS)
  418.     { /* find the constant,  or insert a new one */
  419.     temp = TEMP;
  420.     addr = insert(get_name(buff_psc)+offset,numbytes,0,&temp); /*&perm*/
  421.     if (!unify(op3, (word)addr | CS_TAG)) {Fail0; return;}
  422.      }
  423.     else {/* going backwards */
  424.     Bnameptr = get_name(buff_psc);
  425.     if (!isatom(op3)) {errmsg(5); Fail0; return;}
  426.     Cnameptr = get_name(get_str_psc(op3));
  427.     for (i=0; i<numbytes; i++)    /* copy into buffer */
  428.         Bnameptr[i+offset] = Cnameptr[i];
  429.           }
  430.         /* check or set out location */
  431.     if (!unify(gregc(6), makeint(offset+numbytes))) {Fail0;}
  432. }
  433.  
  434.  
  435. b_SUBNUMBER()
  436. {
  437.        /* reg1 = direction (forwards for read,  backward for write)
  438.           reg2 = number of bytes storing the length
  439.           reg3 = numeric constant
  440.           reg4 = Initial location in buffer
  441.           reg5 = Input Buffer  
  442.           reg6 = Final location in buffer
  443.  
  444.    Forward case: Takes numbytes out of Input Buffer, converts
  445.                  it to a number.  (starting from initial loc in buffer)
  446.                  Binds reg 6 to location in the buffer following the 
  447.                  string representation of the number.
  448.  
  449.  
  450.   Backward case: Takes a numeric constant, stores its name in the
  451.                  Input buffer and binds reg6 to the location in the
  452.                  buffer following the string representation of number */
  453.  
  454.  
  455.    /* define local variables */
  456.     char *Bnameptr;            /* Buffer nameptr */
  457.     struct psc_rec *buff_psc;        /* pointer to psc rec of buffer */
  458.     int num;                 /* Number from subnumber op */
  459.     int numbytes,            /* Number of bytes */
  460.          xtra,                /* Number of leading zeros */
  461.          i,                /* Counter */
  462.          offset;            /* Offset into buffer */
  463.     char s[10];                /* String representation of number */
  464.     word op1, op2, op3, op4, op5;
  465.     register pw top;
  466.  
  467.     op1 = gregc(1); deref(op1);        /* direction */
  468.     op2 = gregc(2); deref(op2);        /* length */
  469.     op3 = gregc(3); deref(op3);        /* numeric constant,  substring */
  470.     op4 = gregc(4); deref(op4);        /* offset */
  471.     op5 = gregc(5); deref(op5);        /* buffer constant, long string */
  472.  
  473.         /* check the direction param for error */
  474.     if (!isinteger(op1)) {errmsg(0); Fail0; return;}
  475.         /* check input buffer - ?valid constant */
  476.     if (!isatom(op5)) {errmsg(8); Fail0; return;}
  477.     buff_psc = get_str_psc(op5);
  478.         /* check that offset is valid */
  479.     if (!isinteger(op4)) {errmsg(2); Fail0; return;}
  480.     offset = intval(op4);
  481.     if ((get_length(buff_psc) < offset) || (offset < 0))
  482.     {errmsg(3); Fail0; return;}
  483.     if (!isinteger(op2))       /* Number of bytes which is the length*/
  484.        {errmsg(6);                 /* of the string representation of the*/
  485.                                    /* number MUST be specified in both   */
  486.                                    /* the forward and backward case.     */
  487.         Fail0; return;}
  488.     numbytes = intval(op2);    /* get the length of const into numbytes  */
  489.         /* check no buffer overflow */
  490.     if ((numbytes < 0) || ((offset+numbytes) > get_length(buff_psc)))
  491.     {errmsg(3); Fail0; return;}
  492.  
  493.    if (intval(op1) != BACKWARDS) {
  494.         /* get numeric equivalent out */
  495.     num = Amigagetnum(numbytes,get_name(buff_psc)+offset); 
  496.     if (!(unify(op3, makeint(num)))) /* unify reg3 with number */
  497.         {Fail0; return;}
  498.     }
  499.     else { /* going backwards */
  500.     if (!isinteger(op3))
  501.           {errmsg(6);        /* no number to be written */
  502.        Fail0; return;}
  503.           num = intval(op3);        /* get number to be written */
  504.           Bnameptr = get_name(buff_psc); /* get buffer name pointer */
  505.       itoa(num,s);            /* make s string representing num */
  506.       xtra = numbytes - strlen(s);    /* number of leading zeros */
  507.       if (xtra < 0) {errmsg(10); Fail0; return;} /* number too large */
  508.       for (i=0; i< xtra; i++)    /* put leading zeros in if any */
  509.         Bnameptr[i+offset] = '0';
  510.           for (i = xtra; i < strlen(s) + xtra; i++)/* put character rep of */
  511.         Bnameptr[i+offset] = s[(i-xtra)];       /* number into buffer*/
  512.     }
  513.         /* check or set out location */
  514.     if (!unify(gregc(6), makeint(offset+numbytes))) {Fail0;}
  515. }   
  516.  
  517.  
  518. b_SUBDELIM()
  519.           /* reg1 = direction     (forwards for read,  backwards for write )
  520.              reg2 = delimiter  
  521.          reg3 = internal constant
  522.          reg4 = Initial location in buffer
  523.          reg5 = Input buffer  
  524.              reg6 = Final location in buffer */
  525.  
  526. /*  Forwards: Takes the characters preceeding the delimiter
  527.               in the input buffer, and creates an internal
  528.           constant with that name.  Binds reg[6] to the 
  529.               location in the buffer following the delimiter.
  530.  
  531.    Backwards: Puts the internal constant into the buffer,
  532.               appends the delimiter to it, binds reg[6] to 
  533.               the final location in the input buffer */
  534.  
  535.  { /* define local variables */
  536.     struct psc_rec *addr;   /* Holds result from insert */
  537.     char *Bnameptr,    /* Buffer Nameptr */
  538.         *Cnameptr,     /* Constant Nameptr */
  539.         *Dnameptr;     /* Delimiter Nameptr */
  540.     struct psc_rec *buff_psc, *con_psc;        /* pointers to psc recs */
  541.     int  offset,       /* Offset into buffer */
  542.           Blen,         /* Buffer length */
  543.           Clen,         /* Constant length */
  544.           i;            /* Counter */
  545.     word op1, op2, op3, op4, op5;
  546.     register pw top;
  547.  
  548.     op1 = gregc(1); deref(op1);        /* direction */
  549.     op2 = gregc(2); deref(op2);        /* delimiter */
  550.     op3 = gregc(3); deref(op3);        /* constant,  substring */
  551.     op4 = gregc(4); deref(op4);        /* offset */
  552.     op5 = gregc(5); deref(op5);        /* buffer constant, long string */
  553.  
  554.         /* check the direction param for error */
  555.         if (!isinteger(op1)) {errmsg(0); Fail0; return;}
  556.         /* check input buffer - ?valid constant */
  557.     if (!isatom(op5)) {errmsg(8); Fail0; return;}
  558.     buff_psc = get_str_psc(op5);
  559.         /* check that offset is valid */
  560.     if (!isinteger(op4)) {errmsg(2); Fail0; return;}
  561.     offset = intval(op4);
  562.     if ((get_length(buff_psc) < offset) || (offset < 0))
  563.     {errmsg(3); Fail0; return;}
  564.  
  565.     if (!isatom(op2))        /* delimiter must be given */
  566.        {errmsg(7); Fail0; return;}
  567.  
  568.     Bnameptr = get_name(buff_psc);        /* get nameptr for Buffer */
  569.     Dnameptr=get_name(get_str_psc(op2));    /* get nameptr for delimiter */
  570.     if (intval(op1) != BACKWARDS) { 
  571.     Blen = get_length(buff_psc);        /* length of Buffer */
  572.            /* get the length of the constant */
  573.     Clen = 0;
  574.     while ((Bnameptr[offset+Clen]!=Dnameptr[0]) && (offset+Clen<Blen))
  575.         Clen++;
  576.     if (offset+Clen >= Blen) {Fail0; return;}
  577.          /* create constant of length Clen */
  578.     temp = TEMP;
  579.     addr = insert(Bnameptr+offset,Clen,0,&temp);
  580.         /* unify this with reg3 */
  581.     if (!(unify(op3, (word)addr | CS_TAG))) 
  582.         {Fail0; return;}
  583.      }
  584.      else {/* going backwards */
  585.     if (isatom(op3)) {  /* make sure there is a constant to write out */
  586.         con_psc = get_str_psc(op3);
  587.         Cnameptr = get_name(con_psc);    /* get cnst nameptr */
  588.             Clen = get_length(con_psc);        /* get length of constant */
  589.         for (i=0;i<Clen;i++)           /* copy constant into buffer */
  590.           Bnameptr[offset+i] = Cnameptr[i];
  591.           Bnameptr[offset + Clen] = Dnameptr[0]; /* copy delimiter into
  592.                                 buffer */
  593.             }
  594.          else {errmsg(5); /* no constant to be written out */
  595.     
  596.                Fail0; return;}
  597.         }
  598.     /* validate or bind outloc */
  599.     if (!unify(gregc(6), makeint(offset+Clen+1))) {Fail0;}
  600.  }
  601.  
  602.  
  603. b_CONLENGTH()
  604. { /* reg 1 is an internal constant or a number */
  605.   /* reg 2 is the length of the constant or number */
  606.  
  607.     register pw top;
  608.     int  len;
  609.     word op1;
  610.  
  611.     op1 = gregc(1); deref(op1);
  612.  
  613.     if (isatom(op1)) len = get_e_length(get_str_psc(op1));
  614.     else if (isinteger(op1)) len = numlength(intval(op1));
  615.     else if (isfloat(op1)) {printf("conlength: FLOAT case not implemented\n"); len = 0;}
  616.     else {errmsg(9); Fail0; return;}
  617.  
  618.     if (!unify(makeint(len), gregc(2))) {Fail0;}
  619. }
  620.  
  621. /*****************************************************************************/
  622. /* Routine name: errmsg                                                      */
  623. /* Input Parameter: errnum  type: short integer                              */
  624. /* Purpose:  To output a relevant message when an error occurs.              */
  625. /*****************************************************************************/
  626. errmsg(errnum)               
  627.  int errnum;
  628.  {switch(errnum) {
  629.    case 0: printf("Error: Direction parameter must must be a 0 or 1.\n");
  630.    case 1: printf("Error: Delimiter not found in buffer.\n");
  631.    case 2: printf("Error: Index into buffer is not an integer.\n");
  632.    case 3: printf("Error: Index into buffer is out of range.\n");
  633.    case 4: printf("Error: Constant and length params are both free or bound improperly.\n");
  634.    case 5: printf("Error: Nothing to write out in sub* backwards.\n");
  635.    case 6: printf("Error: Length must be bound in subnumber operation.\n");
  636.    case 7: printf("Error: Delimiter must be bound in subdelim operation.\n");
  637.    case 8: printf("Error: Input buffer is free or bound improperly.\n");
  638.    case 9: printf("Error: Improper argument to Conlength.\n");
  639.    case 10: printf("Error: Number too large for field in Subnumber.\n");
  640.    case 11: printf("Error: Illegal arg to buff_code.\n");
  641.    }}
  642.